home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / os2 / octa209s.zip / octave-2.09 / libcruft / dassl / xermsg.f < prev    next >
Text File  |  1996-07-19  |  14KB  |  309 lines
  1. C*DECK XERMSG
  2.       SUBROUTINE XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL)
  3. C***BEGIN PROLOGUE  XERMSG
  4. C***PURPOSE  Processes error messages for SLATEC and other libraries
  5. C***LIBRARY   SLATEC
  6. C***CATEGORY  R3C
  7. C***TYPE      ALL
  8. C***KEYWORDS  ERROR MESSAGE, XERROR
  9. C***AUTHOR  FONG, KIRBY, (NMFECC AT LLNL)
  10. C             Modified by
  11. C           FRITSCH, F. N., (LLNL)
  12. C***DESCRIPTION
  13. C
  14. C   XERMSG processes a diagnostic message in a manner determined by the
  15. C   value of LEVEL and the current value of the library error control
  16. C   flag, KONTRL.  See subroutine XSETF for details.
  17. C       (XSETF is inoperable in this version.).
  18. C
  19. C    LIBRAR   A character constant (or character variable) with the name
  20. C             of the library.  This will be 'SLATEC' for the SLATEC
  21. C             Common Math Library.  The error handling package is
  22. C             general enough to be used by many libraries
  23. C             simultaneously, so it is desirable for the routine that
  24. C             detects and reports an error to identify the library name
  25. C             as well as the routine name.
  26. C
  27. C    SUBROU   A character constant (or character variable) with the name
  28. C             of the routine that detected the error.  Usually it is the
  29. C             name of the routine that is calling XERMSG.  There are
  30. C             some instances where a user callable library routine calls
  31. C             lower level subsidiary routines where the error is
  32. C             detected.  In such cases it may be more informative to
  33. C             supply the name of the routine the user called rather than
  34. C             the name of the subsidiary routine that detected the
  35. C             error.
  36. C
  37. C    MESSG    A character constant (or character variable) with the text
  38. C             of the error or warning message.  In the example below,
  39. C             the message is a character constant that contains a
  40. C             generic message.
  41. C
  42. C                   CALL XERMSG ('SLATEC', 'MMPY',
  43. C                  *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION',
  44. C                  *3, 1)
  45. C
  46. C             It is possible (and is sometimes desirable) to generate a
  47. C             specific message--e.g., one that contains actual numeric
  48. C             values.  Specific numeric values can be converted into
  49. C             character strings using formatted WRITE statements into
  50. C             character variables.  This is called standard Fortran
  51. C             internal file I/O and is exemplified in the first three
  52. C             lines of the following example.  You can also catenate
  53. C             substrings of characters to construct the error message.
  54. C             Here is an example showing the use of both writing to
  55. C             an internal file and catenating character strings.
  56. C
  57. C                   CHARACTER*5 CHARN, CHARL
  58. C                   WRITE (CHARN,10) N
  59. C                   WRITE (CHARL,10) LDA
  60. C                10 FORMAT(I5)
  61. C                   CALL XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN//
  62. C                  *   ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'//
  63. C                  *   CHARL, 3, 1)
  64. C
  65. C             There are two subtleties worth mentioning.  One is that
  66. C             the // for character catenation is used to construct the
  67. C             error message so that no single character constant is
  68. C             continued to the next line.  This avoids confusion as to
  69. C             whether there are trailing blanks at the end of the line.
  70. C             The second is that by catenating the parts of the message
  71. C             as an actual argument rather than encoding the entire
  72. C             message into one large character variable, we avoid
  73. C             having to know how long the message will be in order to
  74. C             declare an adequate length for that large character
  75. C             variable.  XERMSG calls XERPRN to print the message using
  76. C             multiple lines if necessary.  If the message is very long,
  77. C             XERPRN will break it into pieces of 72 characters (as
  78. C             requested by XERMSG) for printing on multiple lines.
  79. C             Also, XERMSG asks XERPRN to prefix each line with ' *  '
  80. C             so that the total line length could be 76 characters.
  81. C             Note also that XERPRN scans the error message backwards
  82. C             to ignore trailing blanks.  Another feature is that
  83. C             the substring '$$' is treated as a new line sentinel
  84. C             by XERPRN.  If you want to construct a multiline
  85. C             message without having to count out multiples of 72
  86. C             characters, just use '$$' as a separator.  '$$'
  87. C             obviously must occur within 72 characters of the
  88. C             start of each line to have its intended effect since
  89. C             XERPRN is asked to wrap around at 72 characters in
  90. C             addition to looking for '$$'.
  91. C
  92. C    NERR     An integer value that is chosen by the library routine's
  93. C             author.  It must be in the range -9999999 to 99999999 (8
  94. C             printable digits).  Each distinct error should have its
  95. C             own error number.  These error numbers should be described
  96. C             in the machine readable documentation for the routine.
  97. C             The error numbers need be unique only within each routine,
  98. C             so it is reasonable for each routine to start enumerating
  99. C             errors from 1 and proceeding to the next integer.
  100. C
  101. C    LEVEL    An integer value in the range 0 to 2 that indicates the
  102. C             level (severity) of the error.  Their meanings are
  103. C
  104. C            -1  A warning message.  This is used if it is not clear
  105. C                that there really is an error, but the user's attention
  106. C                may be needed.  An attempt is made to only print this
  107. C                message once.
  108. C
  109. C             0  A warning message.  This is used if it is not clear
  110. C                that there really is an error, but the user's attention
  111. C                may be needed.
  112. C
  113. C             1  A recoverable error.  This is used even if the error is
  114. C                so serious that the routine cannot return any useful
  115. C                answer.  If the user has told the error package to
  116. C                return after recoverable errors, then XERMSG will
  117. C                return to the Library routine which can then return to
  118. C                the user's routine.  The user may also permit the error
  119. C                package to terminate the program upon encountering a
  120. C                recoverable error.
  121. C
  122. C             2  A fatal error.  XERMSG will not return to its caller
  123. C                after it receives a fatal error.  This level should
  124. C                hardly ever be used; it is much better to allow the
  125. C                user a chance to recover.  An example of one of the few
  126. C                cases in which it is permissible to declare a level 2
  127. C                error is a reverse communication Library routine that
  128. C                is likely to be called repeatedly until it integrates
  129. C                across some interval.  If there is a serious error in
  130. C                the input such that another step cannot be taken and
  131. C                the Library routine is called again without the input
  132. C                error having been corrected by the caller, the Library
  133. C                routine will probably be called forever with improper
  134. C                input.  In this case, it is reasonable to declare the
  135. C                error to be fatal.
  136. C
  137. C    Each of the arguments to XERMSG is input; none will be modified by
  138. C    XERMSG.  A routine may make multiple calls to XERMSG with warning
  139. C    level messages; however, after a call to XERMSG with a recoverable
  140. C    error, the routine should return to the user.
  141. C
  142. C***REFERENCES  JONES, RONDALL E. AND KAHANER, DAVID K., "XERROR, THE
  143. C                 SLATEC ERROR-HANDLING PACKAGE", SOFTWARE - PRACTICE
  144. C                 AND EXPERIENCE, VOLUME 13, NO. 3, PP. 251-257,
  145. C                 MARCH, 1983.
  146. C***ROUTINES CALLED  XERHLT, XERPRN
  147. C***REVISION HISTORY  (YYMMDD)
  148. C   880101  DATE WRITTEN
  149. C   880621  REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988.
  150. C           THERE ARE TWO BASIC CHANGES.
  151. C           1.  A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO
  152. C               PRINT MESSAGES.  THIS ROUTINE WILL BREAK LONG MESSAGES
  153. C               INTO PIECES FOR PRINTING ON MULTIPLE LINES.  '$$' IS
  154. C               ACCEPTED AS A NEW LINE SENTINEL.  A PREFIX CAN BE
  155. C               ADDED TO EACH LINE TO BE PRINTED.  XERMSG USES EITHER
  156. C               ' ***' OR ' *  ' AND LONG MESSAGES ARE BROKEN EVERY
  157. C               72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE
  158. C               LENGTH OUTPUT CAN NOW BE AS GREAT AS 76.
  159. C           2.  THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE
  160. C               FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE
  161. C               OF LOWER CASE.
  162. C   880708  REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30.
  163. C           THE PRINCIPAL CHANGES ARE
  164. C           1.  CLARIFY COMMENTS IN THE PROLOGUES
  165. C           2.  RENAME XRPRNT TO XERPRN
  166. C           3.  REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES
  167. C               SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE /
  168. C               CHARACTER FOR NEW RECORDS.
  169. C   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
  170. C           CLEAN UP THE CODING.
  171. C   890721  REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN
  172. C           PREFIX.
  173. C   891013  REVISED TO CORRECT COMMENTS.
  174. C   891214  Prologue converted to Version 4.0 format.  (WRB)
  175. C   900510  Changed test on NERR to be -9999999 < NERR < 99999999, but
  176. C           NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3.  Added
  177. C           LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and
  178. C           XERCTL to XERCNT.  (RWC)
  179. C   901011  Removed error saving features to produce a simplified
  180. C           version for distribution with DASSL and other LLNL codes.
  181. C           (FNF)
  182. C***END PROLOGUE  XERMSG
  183.       CHARACTER*(*) LIBRAR, SUBROU, MESSG
  184.       CHARACTER*72  TEMP
  185. C***FIRST EXECUTABLE STATEMENT  XERMSG
  186. C
  187. C       WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN
  188. C          CALLING XERMSG.  THE ERROR NUMBER SHOULD BE POSITIVE,
  189. C          AND THE LEVEL SHOULD BE BETWEEN 0 AND 2.
  190. C
  191.       IF (NERR.LT.-9999999 .OR. NERR.GT.99999999 .OR. NERR.EQ.0 .OR.
  192.      *   LEVEL.LT.-1 .OR. LEVEL.GT.2) THEN
  193.          CALL XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' //
  194.      *      'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '//
  195.      *      'JOB ABORT DUE TO FATAL ERROR.', 72)
  196.          CALL XERHLT (' ***XERMSG -- INVALID INPUT')
  197.          RETURN
  198.       ENDIF
  199. C
  200. C       SET DEFAULT VALUES FOR CONTROL PARAMETERS.
  201. C
  202.       LKNTRL = 1
  203.       MKNTRL = 1
  204. C
  205. C       ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A
  206. C       MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS)
  207. C       AND SENDING IT OUT VIA XERPRN.  PRINT ONLY IF CONTROL FLAG
  208. C       IS NOT ZERO.
  209. C
  210.       IF (LKNTRL .NE. 0) THEN
  211.          TEMP(1:21) = 'MESSAGE FROM ROUTINE '
  212.          I = MIN(LEN(SUBROU), 16)
  213.          TEMP(22:21+I) = SUBROU(1:I)
  214.          TEMP(22+I:33+I) = ' IN LIBRARY '
  215.          LTEMP = 33 + I
  216.          I = MIN(LEN(LIBRAR), 16)
  217.          TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I)
  218.          TEMP(LTEMP+I+1:LTEMP+I+1) = '.'
  219.          LTEMP = LTEMP + I + 1
  220.          CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
  221.       ENDIF
  222. C
  223. C       IF LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE
  224. C       PRINTING THE MESSAGE.  THE INTRODUCTORY LINE TELLS THE CHOICE
  225. C       FROM EACH OF THE FOLLOWING TWO OPTIONS.
  226. C       1.  LEVEL OF THE MESSAGE
  227. C              'INFORMATIVE MESSAGE'
  228. C              'POTENTIALLY RECOVERABLE ERROR'
  229. C              'FATAL ERROR'
  230. C       2.  WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE
  231. C              'PROGRAM CONTINUES'
  232. C              'PROGRAM ABORTED'
  233. C       NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT
  234. C       EXCEED 74 CHARACTERS.
  235. C       WE SKIP THE NEXT BLOCK IF THE INTRODUCTORY LINE IS NOT NEEDED.
  236. C
  237.       IF (LKNTRL .GT. 0) THEN
  238. C
  239. C       THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL.
  240. C
  241.          IF (LEVEL .LE. 0) THEN
  242.             TEMP(1:20) = 'INFORMATIVE MESSAGE,'
  243.             LTEMP = 20
  244.          ELSEIF (LEVEL .EQ. 1) THEN
  245.             TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,'
  246.             LTEMP = 30
  247.          ELSE
  248.             TEMP(1:12) = 'FATAL ERROR,'
  249.             LTEMP = 12
  250.          ENDIF
  251. C
  252. C       THEN WHETHER THE PROGRAM WILL CONTINUE.
  253. C
  254.          IF ((MKNTRL.EQ.2 .AND. LEVEL.GE.1) .OR.
  255.      *       (MKNTRL.EQ.1 .AND. LEVEL.EQ.2)) THEN
  256.             TEMP(LTEMP+1:LTEMP+17) = ' PROGRAM ABORTED.'
  257.             LTEMP = LTEMP + 17
  258.          ELSE
  259.             TEMP(LTEMP+1:LTEMP+19) = ' PROGRAM CONTINUES.'
  260.             LTEMP = LTEMP + 19
  261.          ENDIF
  262. C
  263.          CALL XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
  264.       ENDIF
  265. C
  266. C       NOW SEND OUT THE MESSAGE.
  267. C
  268.       CALL XERPRN (' *  ', -1, MESSG, 72)
  269. C
  270. C       IF LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER.
  271. C
  272.       IF (LKNTRL .GT. 0) THEN
  273.          WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR
  274.          DO 10 I=16,22
  275.             IF (TEMP(I:I) .NE. ' ') GO TO 20
  276.    10    CONTINUE
  277. C
  278.    20    CALL XERPRN (' *  ', -1, TEMP(1:15) // TEMP(I:23), 72)
  279.       ENDIF
  280. C
  281. C       IF LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE.
  282. C
  283.       IF (LKNTRL .NE. 0) THEN
  284.          CALL XERPRN (' *  ', -1, ' ', 72)
  285.          CALL XERPRN (' ***', -1, 'END OF MESSAGE', 72)
  286.          CALL XERPRN ('    ',  0, ' ', 72)
  287.       ENDIF
  288. C
  289. C       IF THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE
  290. C       CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN.
  291. C
  292.    30 IF (LEVEL.LE.0 .OR. (LEVEL.EQ.1 .AND. MKNTRL.LE.1)) RETURN
  293. C
  294. C       THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A
  295. C       FATAL ERROR.  PRINT THE REASON FOR THE ABORT AND THE ERROR
  296. C       SUMMARY IF THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT.
  297. C
  298.       IF (LKNTRL.GT.0) THEN
  299.          IF (LEVEL .EQ. 1) THEN
  300.             CALL XERPRN
  301.      *         (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72)
  302.          ELSE
  303.             CALL XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72)
  304.          ENDIF
  305.          CALL XERHLT (' ')
  306.       ENDIF
  307.       RETURN
  308.       END
  309.